home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: Franz PD / Franz PD Disk #067 (1990-04)(Amiga User Group Deutschland e.V.).zip / Franz PD Disk #067 (1990-04)(Amiga User Group Deutschland e.V.).adf / Source.zip / StanProcs.p < prev    next >
Text File  |  1989-11-21  |  13KB  |  554 lines
  1. External;
  2.  
  3. {
  4.     Stanprocs.p (of PCQ Pascal)
  5.     Copyright (c) 1989 Patrick Quaid
  6.  
  7.     This routine implements the various standard procedures,
  8.     hence the name.
  9. }
  10.  
  11. {$O-}
  12. {$I "Pascal.i"}
  13.  
  14.     Procedure NextSymbol;
  15.         external;
  16.     Function Match(s : Symbols): Boolean;
  17.         external;
  18.     Procedure Error(s : string);
  19.         external;
  20.     Function Expression(): TypePtr;
  21.         external;
  22.     Function ConExpr(VAR t : TypePtr): Integer;
  23.         external;
  24.     Function TypeCmp(t1, t2 : TypePtr): Boolean;
  25.         external;
  26.     Function TypeCheck(t1, t2 : TypePtr): Boolean;
  27.         external;
  28.     Function LoadAddress() : TypePtr;
  29.         external;
  30.     Procedure Mismatch;
  31.         external;
  32.     Procedure NeedLeftParent;
  33.         external;
  34.     Procedure NeedRightParent;
  35.         external;
  36.     Procedure NeedNumber;
  37.         external;
  38.     Function FindID(s : string) : IDPtr;
  39.         external;
  40.     Function FindWithField(s : String) : IDPtr;
  41.         External;
  42.     Procedure SaveStack(TP : TypePtr);
  43.         external;
  44.     Procedure SaveVal(ID : IDPtr);
  45.         external;
  46.     Procedure ns;
  47.         external;
  48.     Procedure PromoteType(var f : TypePtr; o : TypePtr; r : Short);
  49.         external;
  50.     Function NumberType(t : TypePtr): Boolean;
  51.         external;
  52.     Procedure PushLongD0;
  53.         external;
  54.     Procedure PushWordD0;
  55.         external;
  56.     Procedure PopLongD1;
  57.         external;
  58.     Procedure PopStackSpace(amount : Integer);
  59.         External;
  60.     Procedure PushLongA0;
  61.         External;
  62.     Function Selector(ID : IDPtr) : TypePtr;
  63.         external;
  64.     Function Suffix(size : Integer) : Char;
  65.         External;
  66.  
  67. Procedure CallWrite(TP : TypePtr);
  68.  
  69. {
  70.     This routine calls the appropriate library routine to write
  71. vartype to a text file.
  72. }
  73.  
  74. var
  75.     ElementType    : TypePtr;
  76. begin
  77.     if TypeCmp(TP, RealType) then
  78.     writeln(OutFile, "\tjsr\t_p%WriteReal")
  79.     else if NumberType(TP) then begin
  80.     PromoteType(TP, IntType, 0);
  81.     writeln(OutFile, "\tjsr\t_p%WriteInt");
  82.     end else if TypeCmp(TP, CharType) then
  83.     writeln(OutFile, "\tjsr\t_p%WriteChar")
  84.     else if TypeCmp(TP, BoolType) then
  85.     writeln(OutFile, "\tjsr\t_p%WriteBool")
  86.     else if TP^.Object = ob_array then begin
  87.     ElementType := TP^.SubType;
  88.     if TypeCmp(ElementType, CharType) then begin
  89.         writeln(OutFile, "\tmove.l\t#", TP^.Upper - TP^.Lower + 1, ',d3');
  90.         writeln(OutFile, "\tjsr\t_p%WriteCharray");
  91.     end else
  92.         Error("Write() can only write arrays of char");
  93.     end else if TP = StringType then
  94.     writeln(OutFile, "\tjsr\t_p%WriteString")
  95.     else
  96.     Error("can't write that type to text file");
  97.     if IOCheck then
  98.     Writeln(OutFile, '\tjsr\t_p%CheckIO');
  99. end;
  100.  
  101. Procedure FileWrite(TP : TypePtr);
  102.  
  103. {
  104.     This routine writes a variable to a File of TP
  105. }
  106.  
  107. begin
  108.     writeln(OutFile, "\tmove.l\t#", TP^.Size, ',d3');
  109.     writeln(OutFile, "\tjsr\t_p%WriteArb");
  110.     if IOCheck then
  111.     Writeln(OutFile, '\tjsr\t_p%CheckIO');
  112. end;
  113.  
  114. Procedure DoWrite(ID : IDPtr);
  115.  
  116. {
  117.     This routine handles all aspects of the write and writeln
  118. statements.
  119. }
  120.  
  121. var
  122.     FileType    : TypePtr; { file type if there is one }
  123.     ExprType    : TypePtr; { current element type }
  124.     Pushed    : Boolean; { have pushed the file handle on stack }
  125.     Width    : Integer; { constant field width }
  126.     WidType     : TypePtr; { type of the above }
  127. begin
  128.     if Match(LeftParent1) then begin
  129.     FileType := Expression();
  130.     Pushed := True;
  131.     if FileType^.Object = ob_file then
  132.         PushLongD0
  133.     else begin
  134.         writeln(OutFile, "\tmove.l\t#_Output,-(sp)");
  135.         StackLoad := StackLoad + 4;
  136.         if Match(colon1) then begin
  137.         PushLongD0;
  138.         WidType := Expression();
  139.         if not TypeCheck(IntType, WidType) then
  140.             NeedNumber;
  141.         PopLongD1;
  142.         PushWordD0;
  143.         writeln(OutFile, "\tmove.l\td1,d0");
  144.         end else begin
  145.         writeln(OutFile, "\tmove.w\t#1,-(sp)");
  146.         StackLoad := StackLoad + 2;
  147.         end;
  148.         if TypeCmp(FileType, RealType) then begin
  149.         if Match(colon1) then begin
  150.             PushLongD0;
  151.             WidType := Expression();
  152.             if not TypeCheck(IntType, WidType) then
  153.             NeedNumber;
  154.             PopLongD1;
  155.             PushWordD0;
  156.             writeln(OutFile, "\tmove.l\td1,d0");
  157.         end else begin
  158.             writeln(OutFile, "\tmove.w\t#2,-(sp)");
  159.             StackLoad := StackLoad + 2;
  160.         end;
  161.         end;
  162.         CallWrite(FileType);
  163.         if TypeCmp(FileType, RealType) then
  164.         PopStackSpace(4)
  165.         else
  166.         PopStackSpace(2);
  167.         FileType := TextType;
  168.     end;
  169.     while not Match(RightParent1) do begin
  170.         if not Match(Comma1) then
  171.         Error("expecting , or )");
  172.         ExprType := Expression();
  173.         if FileType = TextType then begin
  174.         if Match(Colon1) then begin
  175.             PushLongD0;
  176.             WidType := Expression();
  177.             if not TypeCheck(IntType, WidType) then
  178.             NeedNumber;
  179.             PopLongD1;
  180.             PushWordD0;
  181.             writeln(OutFile, "\tmove.l\td1,d0");
  182.         end else begin
  183.             writeln(OutFile, "\tmove.w\t#1,-(sp)");
  184.             StackLoad := StackLoad + 2;
  185.         end;
  186.         if TypeCmp(ExprType, RealType) then begin
  187.             if Match(colon1) then begin
  188.             PushLongD0;
  189.             WidType := Expression();
  190.             if not TypeCheck(IntType, WidType) then
  191.                 NeedNumber;
  192.             PopLongD1;
  193.             PushWordD0;
  194.             writeln(OutFile, "\tmove.l\td1,d0");
  195.             end else begin
  196.             writeln(OutFile, "\tmove.w\t#2,-(sp)");
  197.             StackLoad := StackLoad + 2;
  198.             end;
  199.         end;
  200.         CallWrite(ExprType);
  201.         if TypeCmp(ExprType, RealType) then
  202.             PopStackSpace(4)
  203.         else
  204.             PopStackSpace(2);
  205.         end else begin
  206.         if TypeCmp(FileType^.SubType, ExprType) then
  207.             FileWrite(ExprType)
  208.         else
  209.             Mismatch;
  210.         end;
  211.     end;
  212.     end else begin
  213.     FileType := TextType;
  214.     Pushed := False;
  215.     if ID^.Offset = 1 then
  216.         error("'write' requires arguments.");
  217.     end;
  218.     if ID^.Offset = 2 then begin
  219.     if FileType = TextType then begin
  220.         if Pushed then
  221.         writeln(OutFile, "\tjsr\t_p%WriteLn")
  222.         else begin
  223.         writeln(OutFile, "\tmove.l\t#_Output,-(sp)");
  224.         writeln(OutFile, "\tjsr\t_p%WriteLn");
  225.         writeln(OutFile, "\taddq.l\t#4,sp");
  226.         end;
  227.         if IOCheck then
  228.         Writeln(OutFile, '\tjsr\t_p%CheckIO');
  229.     end else
  230.        error("Writeln is only for text files");
  231.     end;
  232.     if Pushed then
  233.     PopStackSpace(4);
  234. end;
  235.  
  236. Procedure CallRead(TP : TypePtr);
  237.  
  238. {
  239.     This routine calls the appropriate library routines to read
  240. the vartype from a text file.
  241. }
  242.  
  243. begin
  244.     if TypeCmp(TP, CharType) then
  245.     writeln(OutFile, "\tjsr\t_p%ReadChar")
  246.     else if TypeCmp(TP, IntType) then begin
  247.     writeln(OutFile, "\tjsr\t_p%ReadInt");
  248.     writeln(OutFile, "\tmove.l\td0,(a0)");
  249.     end else if TypeCmp(TP, ShortType) then begin
  250.     writeln(OutFile, "\tjsr\t_p%ReadInt");
  251.     writeln(OutFile, "\tmove.w\td0,(a0)");
  252.     end else if TypeCmp(TP, RealType) then
  253.     writeln(OutFile, "\tjsr\t_p%ReadReal")
  254.     else if TP^.Object = ob_array then begin
  255.     if TypeCmp(TP^.SubType, chartype) then begin
  256.         writeln(OutFile, "\tmove.l\t#", TP^.Upper - TP^.Lower + 1, ',d3');
  257.         writeln(OutFile, "\tjsr\t_p%ReadCharray");
  258.     end else
  259.         Error("can only read character arrays");
  260.     end else if TP = StringType then
  261.     writeln(OutFile, "\tjsr\t_p%ReadString")
  262.     else
  263.     Error("cannot read that type from a text file");
  264.     if IOCheck then
  265.     Writeln(OutFile, '\tjsr\t_p%CheckIO');
  266. end;
  267.  
  268. Procedure DoRead(ID : IDPtr);
  269.  
  270. {
  271.     This handles the read statement.  Note that read(f, var) from a
  272. non-text file really does end up being var := f^; get(f).  Same
  273. goes for text files, but it's all handled within the library.
  274.     Note the difference between this and dowrite(),
  275. specifically the use of expression() up there and loadaddress()
  276. here.
  277. }
  278.  
  279. var
  280.     FileType,
  281.     VarType    : TypePtr;
  282.     Pushed    : Boolean;
  283. begin
  284.     if Match(LeftParent1) then begin
  285.     FileType := LoadAddress();
  286.     Pushed := True;
  287.     if FileType^.Object = ob_file then
  288.         PushLongA0
  289.     else begin
  290.         writeln(OutFile, "\tmove.l\t#_Input,-(sp)");
  291.         StackLoad := StackLoad + 4;
  292.         CallRead(FileType);
  293.         FileType := TextType;
  294.     end;
  295.     while not Match(RightParent1) do begin
  296.         if not Match(Comma1) then
  297.         Error("expecting , or )");
  298.         VarType := LoadAddress();
  299.         if FileType = TextType then
  300.         CallRead(VarType)
  301.         else begin
  302.         if TypeCmp(FileType^.SubType, VarType) then
  303.             writeln(OutFile, "\tjsr\t_p%ReadArb")
  304.         else
  305.             Mismatch;
  306.         if IOCheck then
  307.             Writeln(OutFile, '\tjsr\t_p%CheckIO');
  308.         end;
  309.     end;
  310.     end else begin
  311.     FileType := TextType;
  312.     Pushed := False;
  313.     if ID^.Offset = 3 then
  314.         error("'read' requires arguments.");
  315.     end;
  316.     if ID^.Offset = 4 then begin
  317.     if TypeCmp(FileType, TextType) then begin
  318.         if Pushed then
  319.         writeln(OutFile, "\tjsr\t_p%ReadLn")
  320.         else begin
  321.         writeln(OutFile, "\tmove.l\t#_Input,-(sp)");
  322.         writeln(OutFile, "\tjsr\t_p%ReadLn");
  323.         writeln(OutFile, "\taddq.l\t#4,sp");
  324.         end;
  325.         if IOCheck then
  326.         Writeln(OutFile, '\tjsr\t_p%CheckIO');
  327.     end else
  328.        error("Readln applies only to Text files");
  329.     end;
  330.     if Pushed then
  331.     PopStackSpace(4);
  332. end;
  333.  
  334. Procedure DoNew;
  335.  
  336. {
  337.     This just handles allocation of memory.
  338. }
  339.  
  340. var
  341.     ID        : IDPtr;
  342.     TP        : TypePtr;
  343.     StackVar    : TypePtr;
  344. begin
  345.     NeedLeftParent;
  346.     ID := FindWithField(SymText);
  347.     if ID = Nil then
  348.     ID := FindID(SymText);
  349.     if ID <> Nil then begin
  350.     NextSymbol;
  351.     StackVar := Selector(ID);
  352.     if StackVar = Nil then
  353.         TP := ID^.VType
  354.     else begin
  355.         PushLongA0;
  356.         TP := StackVar;
  357.     end;
  358.     if TP^.Object <> ob_pointer then
  359.         Error("expecting a pointer type");
  360.     writeln(OutFile, "\tmove.l\t#", TP^.SubType^.Size, ',d0');
  361.     writeln(OutFile, "\tjsr\t_p%new");
  362.     if StackVar = Nil then
  363.         SaveVal(ID)
  364.     else
  365.         SaveStack(TP);
  366.     end else
  367.     Error("Unknown identifier");
  368.     NeedRightParent;
  369. end;
  370.  
  371. Procedure DoDispose;
  372.  
  373. {
  374.     This routine calls the library routine that frees memory.
  375. }
  376.  
  377. var
  378.     ExprType    : TypePtr;
  379. begin
  380.     NeedLeftParent;
  381.     ExprType := Expression();
  382.     if ExprType^.Object <> ob_pointer then
  383.     Error("Expecting a pointer type")
  384.     else
  385.     writeln(OutFile, "\tjsr\t_p%dispose");
  386.     NeedRightParent;
  387. end;
  388.  
  389. Procedure DoClose;
  390.  
  391. {
  392.     Closes a file.  The difference between this and a normal
  393. DOS close is that this routine must un-link the file from the
  394. program's open file list.
  395. }
  396.  
  397. var
  398.     ExprType    : TypePtr;
  399. begin
  400.     NeedLeftParent;
  401.     ExprType := LoadAddress();
  402.     if ExprType^.Object <> ob_file then
  403.     Error("Expecting a file type")
  404.     else
  405.     writeln(OutFile, "\tjsr\t_p%Close");
  406.     if IOCheck then
  407.     Writeln(OutFile, '\tjsr\t_p%CheckIO');
  408.     NeedRightParent;
  409. end;
  410.  
  411. Procedure DoGet;
  412.  
  413. {
  414.     This implements get.
  415. }
  416.  
  417. var
  418.     ExprType    : TypePtr;
  419. begin
  420.     NeedLeftParent;
  421.     ExprType := LoadAddress();
  422.     if ExprType^.Object <> ob_file then
  423.     Error("Expecting a file type")
  424.     else
  425.     Writeln(OutFile, '\tjsr\t_p%Get');
  426.     if IOCheck then
  427.     Writeln(OutFile, '\tjsr\t_p%CheckIO');
  428.     NeedRightParent;
  429. end;
  430.  
  431. Procedure DoPut;
  432.  
  433. {
  434.     This just implements put.  The real guts of these two
  435. routines is in the runtime library.
  436. }
  437.  
  438. var
  439.     ExprType    : TypePtr;
  440. begin
  441.     NeedLeftParent;
  442.     ExprType := LoadAddress();
  443.     if ExprType^.Object <> ob_file then
  444.     Error("Expecting a file type")
  445.     else
  446.     Writeln(OutFile, '\tjsr\t_p%Put');
  447.     if IOCheck then
  448.     Writeln(OutFile, '\tjsr\t_p%CheckIO');
  449.     NeedRightParent;
  450. end;
  451.  
  452. Procedure DoInc;
  453.  
  454. {
  455.     This takes care of Inc.
  456. }
  457.  
  458. var
  459.     ExprType    : TypePtr;
  460. begin
  461.     NeedLeftParent;
  462.     ExprType := LoadAddress();
  463.     with ExprType^ do begin
  464.     case Object of
  465.       ob_ordinal : Writeln(OutFile, '\taddq.',Suffix(Size),'\t#1,(a0)');
  466.       ob_pointer : Writeln(OutFile, '\tadd.l\t#', SubType^.Size,',(a0)');
  467.     else
  468.         Error("Expecting an ordinal or pointer type");
  469.     end;
  470.     end;
  471.     NeedRightParent;
  472. end;
  473.  
  474. Procedure DoDec;
  475.  
  476. {
  477.     This takes care of Dec.
  478. }
  479.  
  480. var
  481.     ExprType    : TypePtr;
  482. begin
  483.     NeedLeftParent;
  484.     ExprType := LoadAddress();
  485.     with ExprType^ do begin
  486.     case Object of
  487.       ob_ordinal : Writeln(OutFile, '\tsubq.',Suffix(Size),'\t#1,(a0)');
  488.       ob_pointer : Writeln(OutFile, '\tsub.l\t#', SubType^.Size,',(a0)');
  489.     else
  490.         Error("Expecting an ordinal or pointer type");
  491.     end;
  492.     end;
  493.     NeedRightParent;
  494. end;
  495.  
  496. Procedure DoExit;
  497.  
  498. {
  499.     Just calls the routine that allows the graceful shut-down
  500. of the program.
  501. }
  502.  
  503. var
  504.     ExprType : TypePtr;
  505. begin
  506.     NeedLeftParent;
  507.     ExprType := Expression();
  508.     if not TypeCheck(ExprType, IntType) then
  509.     Error("Expecting an integer argument.");
  510.     writeln(OutFile, "\tjsr\t_p%exit");
  511.     NeedRightParent;
  512. end;
  513.  
  514. Procedure DoTrap;
  515.  
  516. {
  517.     This is just for debugging a program.  Use some trap, and
  518. your debugger will stop at that statement.
  519. }
  520.  
  521. var
  522.     ExprType  : TypePtr;
  523.     TrapNum   : Integer;
  524. begin
  525.     NeedLeftParent;
  526.     TrapNum := ConExpr(ExprType);
  527.     writeln(OutFile, "\ttrap\t#", trapnum);
  528.     NeedRightParent;
  529. end;
  530.  
  531. Procedure StdProc(ProcID : IDPtr);
  532.  
  533. {
  534.     This routine sifts out the proper routine to call.
  535. }
  536.  
  537. begin
  538.     NextSymbol;
  539.     case ProcID^.Offset of
  540.       1,2 : DoWrite(ProcID);
  541.       3,4 : DoRead(ProcID);
  542.       5   : DoNew;
  543.       6   : DoDispose;
  544.       7   : DoClose;
  545.       8   : DoGet;
  546.       9   : DoExit;
  547.       10  : DoTrap;
  548.       11  : DoPut;
  549.       12  : DoInc;
  550.       13  : DoDec;
  551.     end;
  552. end;
  553.  
  554.